home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / DOCDEMOS.PAK / PALTEST.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  4KB  |  131 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program PaletteTest;
  10.  
  11. {$R-}
  12.  
  13. uses WObjects, WinTypes, WinProcs;
  14.  
  15. const
  16.   NumColors = 8;
  17.   RedVals : array[0..NumColors - 1] of Byte =
  18.     (0, 0, 0, 0, $FF, $FF, $FF, $FF);
  19.   GreenVals : array[0..NumColors - 1] of Byte =
  20.     (0, 0, $FF, $FF, 0, 0, $FF, $FF);
  21.   BlueVals : array[0..NumColors - 1] of Byte =
  22.     (0, $FF, 0, $FF, 0, $FF, 0, $FF);
  23.  
  24. type 
  25.  
  26.   PaletteApplication = object(TApplication)
  27.     procedure InitMainWindow; virtual;
  28.   end;
  29.  
  30.   PTestWindow = ^TestWindow;
  31.   TestWindow = object(TWindow)
  32.     MyLogPalette: PLogPalette;
  33.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  34.     destructor Done; virtual;
  35.     procedure WMLButtonDown(var Msg: TMessage);
  36.       virtual wm_First + wm_LButtonDown;
  37.     procedure WMRButtonDown(var Msg: TMessage);
  38.       virtual wm_First + wm_RButtonDown;
  39.   end;
  40.  
  41. {  Helpful function for dealing with palette-index TColorRefs }
  42.        
  43. function PaletteIndex(W: Word): TColorRef;
  44. begin
  45.   PaletteIndex := $01000000 or W;
  46. end;
  47.    
  48. {--------------------------------------------------}
  49. { TestWindow method implementations:               }
  50. {--------------------------------------------------}
  51.  
  52. constructor TestWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  53. var
  54.   i: Integer;
  55. begin
  56.   TWindow.Init(AParent, ATitle);
  57.   GetMem(MyLogPalette, SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * NumColors);
  58.   MyLogPalette^.palVersion := $300;
  59.   MyLogPalette^.palNumEntries := NumColors;
  60.   for i := 0 to NumColors - 1 do
  61.   begin
  62.     MyLogPalette^.palPalEntry[i].peRed := RedVals[i];
  63.     MyLogPalette^.palPalEntry[i].peGreen := GreenVals[i];
  64.     MyLogPalette^.palPalEntry[i].peBlue := BlueVals[i];
  65.     MyLogPalette^.palPalEntry[i].peFlags := pc_Reserved;
  66.   end;
  67. end;
  68.  
  69. destructor TestWindow.Done;
  70. begin
  71.   FreeMem(MyLogPalette, (sizeof(TLogPalette) + sizeof(TPaletteEntry) * NumColors ));
  72.   TWindow.Done;
  73. end;
  74.  
  75. procedure TestWindow.WMLButtonDown(var Msg: TMessage);
  76. var
  77.   i: Integer;
  78.   ABrush, OldBrush: HBrush;
  79.   OldPalette: HPalette;
  80.   ThePalette: HPalette;
  81.   TheDC: HDC;
  82. begin
  83.   ThePalette := CreatePalette(MyLogPalette^);
  84.   TheDC := GetDC(HWindow);
  85.   OldPalette := SelectPalette(TheDC, ThePalette, False);
  86.   RealizePalette(TheDC);
  87.   for i := 0 to NumColors - 1 do
  88.   begin
  89.     ABrush := CreateSolidBrush(PaletteIndex(i));
  90.     OldBrush := SelectObject(TheDC, ABrush);
  91.     Rectangle(TheDC, i * 25, i * 25, i * 25 + 20, i * 25 + 20);
  92.     SelectObject(TheDC, OldBrush);
  93.     DeleteObject(ABrush);
  94.   end;
  95.   SelectPalette(TheDC, OldPalette, False);
  96.   ReleaseDC(HWindow, TheDC);
  97.   DeleteObject(ThePalette);
  98. end;
  99.  
  100. procedure TestWindow.WMRButtonDown(var Msg: TMessage);
  101. var
  102.   i: Integer;
  103.   APaletteEntry : TPaletteEntry;
  104. begin
  105.   APaletteEntry := MyLogPalette^.palPalEntry[0];
  106.   for i := 0 to NumColors - 2 do
  107.     MyLogPalette^.palPalEntry[i] := MyLogPalette^.palPalEntry[i + 1] ;
  108.   i := NumColors - 1;
  109.   MyLogPalette^.palPalEntry[i] := APaletteEntry;
  110. end;
  111.  
  112. {--------------------------------------------------}
  113. { PaletteApplication method implementations:       }
  114. {--------------------------------------------------}
  115.  
  116. procedure PaletteApplication.InitMainWindow;
  117. begin
  118.   MainWindow := New(PTestWindow,Init(nil, 'Test Palettes'));
  119. end;
  120.  
  121. {--------------------------------------------------}
  122. { Main program:                                    }
  123. {--------------------------------------------------}
  124. var
  125.    PalApp: PaletteApplication;
  126. begin
  127.   PalApp.Init('PaletteApp');
  128.   PalApp.Run;
  129.   PalApp.Done;
  130. end.
  131.